(**
 * errors generated by match compiler.
 * @author OSAKA Satoshi
 * @version $Id: MatchError.ppg,v 1.8 2008/03/11 08:53:55 katsu Exp $
 *)
structure MatchError = 
struct
local
  structure TC = TypedCalc
  (* structure BF = SMLFormat.BasicFormatters *)
  structure A = AbsynConst
  structure MD = MatchData
  structure BT = BuiltinTypes
  structure T = Types
  structure UE = UserError
  fun bug s = Bug.Bug ("MatchData: " ^ s)
in
  fun format_flag x = 
      if !x = 0
      then [SMLFormat.FormatExpression.Term(4,"--> ")]
      else [SMLFormat.FormatExpression.Term(4,"    ")]

  (*%
   * @formatter(TC.tppat) TC.format_tppat
   * @formatter(flag) format_flag
   *)
  type rule
  = (*%
     * @format((pat pats* exp) * flag)
     *          flag:flag 4[{pats(pat)(","+1)} + "=>" + "..."]
     *)
    (TC.tppat list * TC.tpexp) * int ref

  local
    val format_rule' = format_rule
  in
  (*%
   * @formatter(rule) format_rule'
   *)
  exception
  (*%
   * @format(message * rule rules) message \n rules(rule)(\n)
   *)
  MatchError of string * rule list
  end

  val bindRedundantMessage = "binding redundant"
  val bindNotExhaustiveMessage = "binding not exhaustive"
  val bindBothMessage = "binding redundant and not exhaustive"
  val matchRedundantMessage = "match redundant"
  val matchNotExhaustiveMessage = "match nonexhaustive"
  val matchBothMessage = "match redundant and nonexhaustive"

  fun raiseBindFailExp resultTy loc = 
      TC.TPRAISE
        {exp=TC.TPEXNCONSTRUCT{exn=TC.EXEXN BT.BindExExn,
                               argExpOpt=NONE, 
                               loc=loc}, 
         ty=resultTy,
         loc=loc}

  fun raiseMatchFailExp resultTy loc = 
      TC.TPRAISE
        {exp=TC.TPEXNCONSTRUCT{exn=TC.EXEXN BT.MatchExExn,
                               argExpOpt=NONE, 
                               loc=loc}, 
         ty=resultTy, 
         loc=loc}

  fun handleFail v resultTy loc =
      TC.TPRAISE {exp=TC.TPVAR v, ty=resultTy, loc=loc}

  fun raiseMatchCompBugExp resultTy loc =
      let
        val attributes = {isPure = false, fast = true, unsafe = false,
                          causeGC = false, callingConvention = NONE}
      in
        TC.TPLET
          {decls =
             [TC.TPVAL
                ((TypedCalcUtils.newTCVarInfo loc BT.unitTy,
                  TC.TPFOREIGNAPPLY
                    {funExp =
                       TC.TPFOREIGNSYMBOL
                         {name = "sml_matchcomp_bug",
                          ty = T.BACKENDty
                                 (T.FOREIGNFUNPTRty
                                    {attributes = attributes,
                                     argTyList = nil,
                                     varArgTyList = NONE,
                                     resultTy = NONE}),
                          loc = loc},
                     argExpList = nil,
                     attributes = attributes,
                     resultTy = NONE,
                     loc = loc}),
                 loc)],
           body =
             TC.TPRAISE
               {exp = TC.TPEXNCONSTRUCT
                        {exn = TC.EXEXN BT.MatchExExn,
                         argExpOpt = NONE,
                         loc = loc},
                ty = resultTy,
                loc = loc},
           loc = loc}
      end

  datatype flagKind = Redundant | NotExhaustive
  local
    val errorMessages = ref [] : UE.errorInfo list ref
    val redundantFlag = ref false
    val notExhaustiveFlag = ref false
  in
    fun clearErrorMessages () = errorMessages := []
    fun putErrorMessage (loc, kind, message, rules) =
        errorMessages :=
        (loc, kind, MatchError (message, rules)) :: (! errorMessages)
    fun getErrorMessages () = ! errorMessages
    fun clearFlag Redundant = redundantFlag := false
      | clearFlag NotExhaustive = notExhaustiveFlag := false
    fun setFlag Redundant = redundantFlag := true
      | setFlag NotExhaustive = notExhaustiveFlag := true
    fun isRedundant () = ! redundantFlag
    fun isNotExhaustive () = ! notExhaustiveFlag
  end

  fun haveRedundantRules [] = false
    | haveRedundantRules ((_, flag) :: rules) =
      if !flag then true
      else haveRedundantRules rules

(*
  val print = C.prettyPrint
*)

  fun insertNewline messages =
      let
	fun insert [] = []
	  | insert [message] = [message]
	  | insert (message :: messages) = message :: "\n" :: insert messages
      in
	concat (insert messages)
      end

  fun checkError (MD.Handle v, true, _, rules, loc ) = 
      putErrorMessage (loc, UE.Error, matchRedundantMessage, rules)
    | checkError (MD.Bind, true, true, rules, loc) = 
      putErrorMessage (loc, UE.Error, bindBothMessage, rules)
    | checkError (MD.Bind, true, false, rules, loc) = 
      putErrorMessage (loc, UE.Error, bindRedundantMessage, rules)
    | checkError (MD.Bind, false, true, rules, loc) = 
      putErrorMessage (loc, UE.Warning, bindNotExhaustiveMessage, rules)
    | checkError (MD.Match, true, true, rules, loc) = 
      putErrorMessage (loc, UE.Error, matchBothMessage, rules)
    | checkError (MD.Match, true, false, rules, loc) = 
      putErrorMessage (loc, UE.Error, matchRedundantMessage, rules)
    | checkError (MD.Match, false, true, rules, loc) = 
      putErrorMessage (loc, UE.Warning, matchNotExhaustiveMessage, rules)
    | checkError _ = ()
end
end
